home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / COMM / RPL60 / RPLPAT.INC < prev    next >
Text File  |  1992-12-31  |  12KB  |  312 lines
  1.  
  2.   {*}
  3.   {*source code copyright (c) 1985, by TurboPower Software*}
  4.   {*}
  5.   {*}
  6.  
  7.   procedure WritePat(PatRec : PatPtr);
  8.     {-list the pattern list starting at patrec}
  9.   var
  10.     j              : PatPtr;
  11.   begin
  12.     j := PatRec;
  13.     while j <> nil do begin
  14.       case j^.Tok of
  15.         tClosure : Wr(Closure);
  16.         tLitChar : Wr(j^.One);
  17.         tCcl : Wr(Ccl+j^.StrPtr^+CclEnd);
  18.         tnCcl : Wr(Ccl+Negate+j^.StrPtr^+CclEnd);
  19.         tBol : Wr(Bol);
  20.         tEol : Wr(Eol);
  21.         tAny : Wr(Any);
  22.         tbTag : Wr(BTag);
  23.         teTag : Wr(ETag);
  24.         tGroup : begin
  25.                    Wr(BGroup);
  26.                    WritePat(j^.NestPtr);
  27.                    Wr(EGroup);
  28.                  end;
  29.         tDitto : begin
  30.                    Wr(Ditto+'('+j^.One+')');
  31.                  end;
  32.         tMaybeOne : begin
  33.                       Wr(MaybeOne);
  34.                     end;
  35.       end;
  36.       if j^.NexTok then Wr(Alter);
  37.       j := j^.Next;
  38.     end;
  39.   end;                            {writepat}
  40.  
  41.   function GetPat(var arg : PatLine; var PatList : PatPtr) : Boolean;
  42.     {-convert argument into a pattern list, pointed to by patlist}
  43.     {-return true if successful}
  44.   var
  45.     TagOn          : Boolean;
  46.  
  47.     function MakePat(var arg : PatLine; Start : Integer; Delim : Char; var PatList : PatPtr) : Integer;
  48.       {-make a pattern list from arg[i], starting at start, ending at delim}
  49.       {-return 0 if error, last char position in arg if OK}
  50.     var
  51.       i              : Integer;
  52.       nLastj, Lastj, tj, j : PatPtr;
  53.       Done           : Boolean;
  54.       c              : Char;
  55.       ts             : LongString;
  56.       tTok           : Tokens;
  57.  
  58.       procedure AddPat(Tok : Tokens; Lastj : PatPtr; var j : PatPtr; s : LongString);
  59.         {-add a token record to the pattern list}
  60.         {-s contains a literal character or an expanded character class}
  61.  
  62.         function CleanUpCase(var s : LongString) : LongString;
  63.           {-convert string to uppercase and remove duplicates}
  64.         var
  65.           i              : Integer;
  66.           c              : Char;
  67.           tOut           : LongString;
  68.         begin
  69.           tOut := '';
  70.           for i := 1 to Length(s) do begin
  71.             c := UpCaseMac(s[i]);
  72.             if Pos(c, tOut) = 0 then tOut := tOut+c;
  73.           end;
  74.           CleanUpCase := tOut;
  75.         end;                      {cleanupcase}
  76.  
  77.       begin
  78.         New(j);                   {allocate a new pointer for this token}
  79.         j^.Tok := Tok;            {save token type}
  80.         j^.NexTok := False;       {default to non-alternation}
  81.         j^.NestPtr := nil;        {nestptr and next are filled in later}
  82.         j^.Next := nil;
  83.         Lastj^.Next := j;         {hook up the previous token}
  84.         case Tok of
  85.           tNil, tAny, tBol, tEol, tGroup, tbTag, teTag :
  86.             begin
  87.               j^.One := Null;
  88.               j^.StrPtr := nil;
  89.             end;
  90.           tLitChar :
  91.             begin
  92.                 if IgnoreCase then j^.One := UpCaseMac(s[1]) else j^.One := s[1];
  93.               j^.StrPtr := nil;
  94.             end;
  95.           tCcl, tnCcl :
  96.             begin
  97.               j^.One := Null;
  98.               if IgnoreCase then s := CleanUpCase(s);
  99.               New(j^.StrPtr);
  100.               j^.StrPtr^ := s;
  101.             end;
  102.         else
  103.           WrL('addpat:can''t happen');
  104.           Halt;
  105.         end;
  106.       end;                        {addpat}
  107.  
  108.       function GetCcl(var arg : PatLine; var i : Integer;
  109.                       {-} var s : LongString; var tTok : Tokens) : Boolean;
  110.         {-expand a character class starting at position i of arg into a string s}
  111.         {return a token type (tccl or tnccl)}
  112.         {return i pointing at the end of class character}
  113.         {return true if successful}
  114.  
  115.         procedure DoDash(Delim : Char; var arg : PatLine; var i : Integer; var s : LongString);
  116.           {-expand the innards of the character class, including dashes}
  117.           {stop when endc is found}
  118.           {return a string s with the expansion}
  119.         var
  120.           c, cl, cn      : Char;
  121.           j, k           : Integer;
  122.  
  123.           procedure AddStr(c : Char; var j : Integer; var s : LongString);
  124.             {-append a character c onto string s and increment position}
  125.           begin
  126.             j := Succ(j);
  127.             s[j] := c;
  128.           end;                    {addstr}
  129.  
  130.           function IsAlphaNum(c : Char) : Boolean;
  131.             {-return true if character is in a-z, A-Z, or 0-9}
  132.           begin
  133.             if (c >= 'a') and (c <= 'z') then IsAlphaNum := True
  134.             else if (c >= 'A') and (c <= 'Z') then IsAlphaNum := True
  135.             else if (c >= '0') and (c <= '9') then IsAlphaNum := True
  136.             else IsAlphaNum := False;
  137.           end;                    {isalphanum}
  138.  
  139.         begin
  140.           j := 0;
  141.           while (arg[i] <> Delim) and (arg[i] <> EndStr) do begin
  142.             c := arg[i];
  143.             if (c = Esc) then begin
  144.               if (arg[Succ(i)] <> EndStr) then begin
  145.                 i := Succ(i);
  146.                 c := arg[i];
  147.                 case c of
  148.                   lSpace : AddStr(#32, j, s);
  149.                   lTab : AddStr(#9, j, s);
  150.                   lBackSpace : AddStr(#8, j, s);
  151.                   lReturn : AddStr(#13, j, s);
  152.                   lFeed : AddStr(#10, j, s);
  153.                   lInput : AddStr(#60, j, s);
  154.                   lOutput : AddStr(#62, j, s);
  155.                   lPipe : AddStr(#124, j, s);
  156.                 else
  157.                   AddStr(c, j, s);
  158.                 end;
  159.               end else
  160.                 {escape must be the character}
  161.                 AddStr(Esc, j, s);
  162.             end else if c <> Dash then
  163.               {literal character}
  164.               AddStr(c, j, s)
  165.             else if (j = 0) or (arg[Succ(i)] = Delim) then
  166.               {literal dash at begin or end of class}
  167.               AddStr(Dash, j, s)
  168.             else begin
  169.               {dash in middle of class}
  170.               cl := arg[Pred(i)];
  171.               cn := arg[Succ(i)];
  172.               if IsAlphaNum(cl) and IsAlphaNum(cn) and (cl <= cn) then begin
  173.                 {legal dash to be expanded}
  174.                 for k := (Ord(cl)+1) to Ord(cn) do AddStr(Chr(k), j, s);
  175.                 {move over the end of dash character}
  176.                 i := Succ(i);
  177.               end else
  178.                 {dash must be a literal}
  179.                 AddStr(Dash, j, s);
  180.             end;
  181.             i := Succ(i);
  182.           end;
  183.           s[0] := Chr(j);
  184.         end;                      {dodash}
  185.  
  186.       begin                       {getccl}
  187.         i := Succ(i);             {skip over start of class character}
  188.         if arg[i] = Negate then begin
  189.           tTok := tnCcl;
  190.           i := Succ(i);
  191.         end else tTok := tCcl;
  192.         {expand the character class}
  193.         DoDash(CclEnd, arg, i, s);
  194.         GetCcl := (arg[i] = CclEnd);
  195.       end;                        {getccl}
  196.  
  197.     begin                         {makepat}
  198.       New(PatList);               {starter point for patlist}
  199.       PatList^.Tok := tNil;       {put a nil token at the beginning}
  200.       PatList^.NexTok := False;
  201.       Lastj := PatList;
  202.       nLastj := nil;
  203.       i := Start;                 {start point of pattern string}
  204.       Done := False;
  205.       while not(Done) and (arg[i] <> Delim) and (arg[i] <> EndStr) do begin
  206.         c := arg[i];
  207.         if c = Any then AddPat(tAny, Lastj, j, c)
  208.         else if (c = Bol) then AddPat(tBol, Lastj, j, '')
  209.         else if (c = Eol) then AddPat(tEol, Lastj, j, '')
  210.         else if (c = Ccl) then begin
  211.           Done := (GetCcl(arg, i, ts, tTok) = False);
  212.           if Done then WrL('problem in expanding character class');
  213.           AddPat(tTok, Lastj, j, ts);
  214.         end else if (c = Alter) then begin
  215.           if (nLastj = nil) or
  216.           ((nLastj^.Tok <> tClosure) and (nLastj^.Tok <> tMaybeOne)) then begin
  217.             {flag the current token as non-critical, i.e., "next is OK"}
  218.             Lastj^.NexTok := True;
  219.           end else begin
  220.             {alternation immediately after a closure is probably not desired}
  221.             {e.g., [a-z]*#[0-9] would internally produce ([a-z]#[0-9])*}
  222.             WrL('alternation cannot immediately follow a closure marker');
  223.             Done := True;
  224.           end;
  225.         end else if (c = BGroup) then begin
  226.           AddPat(tGroup, Lastj, j, '');
  227.           {recursive branch off the list}
  228.           i := MakePat(arg, Succ(i), EGroup, tj);
  229.           if i > 0 then
  230.             j^.NestPtr := tj
  231.           else begin
  232.             {didn't find egroup}
  233.             WrL('unbalanced nesting parentheses');
  234.             Done := True;
  235.           end;
  236.         end else if (c = BTag) and not(TagOn) then begin
  237.           AddPat(tbTag, Lastj, j, '');
  238.           TagOn := True;
  239.         end else if (c = ETag) and TagOn then begin
  240.           AddPat(teTag, Lastj, j, '');
  241.           TagOn := False;
  242.         end else if ((c = Closure) or (c = ClosurePlus) or (c = MaybeOne))
  243.         and (i > Start) then begin
  244.           if (Lastj^.Tok in [tBol, tEol, tMaybeOne, tClosure]) then begin
  245.             {error, can't have closure after any of these}
  246.             WrL('closure cannot immediately follow BegOfLine, EndOfLine or another closure');
  247.             Done := True;
  248.           end else begin
  249.             if (c = ClosurePlus) then begin
  250.               {insert an extra copy of the last token before the closure}
  251.               New(tj);
  252.               nLastj^.Next := tj;
  253.               tj^ := Lastj^;
  254.               nLastj := tj;
  255.             end;
  256.             {insert the closure between next to last and last token}
  257.             New(tj);
  258.             nLastj^.Next := tj;
  259.               if c = MaybeOne then tj^.Tok := tMaybeOne else tj^.Tok := tClosure;
  260.             tj^.One := Null; tj^.StrPtr := nil; tj^.NestPtr := nil;
  261.             tj^.Next := Lastj;
  262.             tj^.NexTok := False;
  263.             {set j and lastj back into sequence}
  264.             j := Lastj;
  265.             Lastj := tj;
  266.           end;
  267.         end else begin
  268.           if c = Esc then begin
  269.             {skip over escape character}
  270.             i := Succ(i);
  271.             c := arg[i];
  272.             case c of
  273.               lSpace : AddPat(tLitChar, Lastj, j, #32);
  274.               lNewline : begin
  275.                            AddPat(tLitChar, Lastj, j, #13);
  276.                            nLastj := Lastj;
  277.                            Lastj := j;
  278.                            AddPat(tLitChar, Lastj, j, #10);
  279.                          end;
  280.               lTab : AddPat(tLitChar, Lastj, j, #9);
  281.               lBackSpace : AddPat(tLitChar, Lastj, j, #8);
  282.               lReturn : AddPat(tLitChar, Lastj, j, #13);
  283.               lFeed : AddPat(tLitChar, Lastj, j, #10);
  284.               lInput : AddPat(tLitChar, Lastj, j, #60);
  285.               lOutput : AddPat(tLitChar, Lastj, j, #62);
  286.               lPipe : AddPat(tLitChar, Lastj, j, #124);
  287.               lWordDelim : AddPat(tCcl, Lastj, j, wDelimString);
  288.               lHex : AddPat(tCcl, Lastj, j, '0123456789ABCDEF');
  289.             else
  290.               AddPat(tLitChar, Lastj, j, c);
  291.             end;
  292.           end else AddPat(tLitChar, Lastj, j, c);
  293.         end;
  294.         nLastj := Lastj;
  295.         Lastj := j;
  296.         if not(Done) then i := Succ(i);
  297.       end;                        {of looking through pattern string}
  298.       if Done or (arg[i] <> Delim) then begin
  299.         MakePat := 0;
  300.         WrL('error detected near end of '+Copy(arg, 1, i));
  301.       end else MakePat := i;
  302.     end;                          {makepat}
  303.  
  304.   begin                           {getpat}
  305.     TagOn := False;
  306.     GetPat := (MakePat(arg, 1, EndStr, PatList) > 0);
  307.     if TagOn then begin
  308.       GetPat := False;
  309.       WrL('pattern error: unbalanced tag marker');
  310.     end;
  311.   end;                            {getpat}
  312.